home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Module source / callsMod.txt < prev    next >
Encoding:
Text File  |  1995-11-25  |  6.4 KB  |  307 lines  |  [TEXT/MSET]
  1. false    constant    debug?
  2.  
  3. file  INPF
  4.  
  5. : #ALIGN4    \ ( n -- n' )
  6.     3 + $ fffffffc and  ;
  7.  
  8.  
  9. true -> case_in_names?
  10.  
  11. : macConstant
  12.     [ FALSE -> CASE_IN_NAMES? ]
  13.     >in @
  14.     defined?
  15.     IF        ['] inpf u>  IF  2drop  EXIT  THEN
  16.     ELSE    drop
  17.     THEN
  18.     >in !
  19.     constant
  20. ;
  21.  
  22.  
  23. (* ****
  24.    I don't want to handle conditionals any more - I think we mightn't have the
  25.    nesting 100% right, and anyway we do want to make the old routine names
  26.    available - and likewise any other sort of alternative names.
  27.  
  28. forward  [IF]
  29.  
  30. : gobble_conditional  { \ level addr len -- }
  31.     1 -> level                    \ initial level count
  32.     +echo        \ let's see what we're skipping
  33.     BEGIN
  34.         Mword  count  -> len  -> addr
  35.         addr len " [IF]"  s=
  36.         IF    1 ++> level                    \ increment level count
  37.         ELSE
  38.             addr len " [THEN]"  s=
  39.             IF  1 --> level                \ decrement level count
  40.                 level  0EXIT            \ and if zero, we're done
  41.             ELSE
  42.                 level 1 =
  43.                 IF        \ at lev 1, we need to check for [ELSE] and [ELIF]
  44.                     addr len " [ELSE]" s=  ?EXIT
  45.                     addr len " [ELIF]" s=  ?EXIT    \ there's only one, and it doesn't
  46.                                                     \  do anything
  47.                 THEN
  48.             THEN
  49.         THEN
  50.     AGAIN
  51. ;
  52.  
  53.  
  54. :f [IF]      NIF  gobble_conditional  -echo THEN  ;f
  55. : [ELSE]    gobble_conditional -echo  ;
  56. : [THEN]    ;
  57. : [ELIF]    drop gobble_conditional -echo  ;
  58.  
  59. **** *)
  60.  
  61. : [IF]        drop  ;
  62. : [ELSE]    ;
  63. : [THEN]    ;
  64. : [ELIF]    drop  ;
  65.  
  66.  
  67. true -> case_in_names?
  68.  
  69. : macDefined?    DEFINED? NIP  ;
  70. : macStruct        MWORD DROP  ;
  71. : macUnion        MWORD DROP    ;
  72. : macField        DROP  MWORD DROP  ;
  73. : macFiller        2DROP  ;
  74. : macEnd-struct    2DROP  ;
  75. : macEnd-union    2DROP  ;
  76. : macSynonym    MWORD DROP  MWORD DROP  ;
  77.  
  78. : and            AND  ;
  79. : or            OR   ;
  80. : xor            XOR  ;
  81. : lshift        LSHIFT  ;
  82. : rshift        RSHIFT  ;
  83. : negate        NEGATE  ;
  84. : 'type            POSTPONE 'TYPE  ;  IMMEDIATE
  85.  
  86.  
  87. FALSE -> CASE_IN_NAMES?
  88.  
  89.  
  90. string temp
  91.  
  92. : READ_INLINE  { \ loc svd svCaseFlg -- }
  93.     case_in_names? -> svCaseFlg
  94.     false -> case_in_names?
  95.     clear: temp
  96.     BEGIN
  97.         >in @  src-len  >=
  98.         IF    svCaseFlg -> case_in_names?  EXIT
  99.         THEN
  100.         hex  mword number  decimal
  101.         pad w!  pad 2 add: temp
  102.     AGAIN  ;
  103.  
  104.  
  105. false    value    register_based?
  106. 0        value    ^hndlr
  107.  
  108. : 68k_parm_adjust  { parm parm# parm? -- parm' }
  109.     parm -1 =
  110.     NIF
  111.         parm $ ffff0000 and
  112.         IF                        \ it's a register parm
  113.             true -> register_based?
  114.             $ D001  ^hndlr w!
  115.             parm 16 >>  EXIT
  116.         THEN
  117.     THEN
  118.     
  119.     parm?                        \ parm or result?
  120.     IF                            \ parm
  121.         register_based?
  122.         IF ." warning - non-reg parm in reg-based call  "
  123.             latest name> .id  cr
  124.         THEN
  125.         parm
  126. \        dup 1 and +            \ &&& don't round length any more
  127.     ELSE                        \ result
  128.         parm IF
  129.             register_based?
  130.             IF ." warning - non-reg result in reg-based call  "
  131.                 latest name> .id  cr
  132.             THEN
  133.         THEN
  134.         parm                        \ for results, we don't round so call
  135.     THEN                            \  windup gets done properly.
  136. ;
  137.  
  138.  
  139.     true -> case_in_names?
  140.  
  141. : macExtern
  142.  
  143.     [ FALSE -> CASE_IN_NAMES? ]
  144.  
  145.         { \ #parms #cells ^PPCinfo ^68kInfo -- }
  146.  
  147.     0 -> #cells  false -> register_based?
  148. \    true -> case_in_names?
  149.     >in @
  150.     defined?
  151.     IF    ['] inpf u>
  152.         IF  drop                    \ drop >in - now TOS is # parms
  153.             -1 DO  2drop  LOOP        \ drop parm info, also result info
  154.             0 -> src-len            \ skip 68k inline code sequence
  155. \            false -> case_in_names?
  156.             EXIT
  157.         THEN
  158.     ELSE    drop
  159.     THEN
  160.  
  161.     >in !
  162.     create                        \ create the new dic entry (case sensitive)
  163. \    false -> case_in_names?
  164.     DP 2-  -> ^hndlr
  165.     $ D000  ^hndlr w!            \ dummy "handler code"
  166.     DP -> ^PPCinfo  0 w,        \ leave space for PPC info
  167.     
  168. \ #parms
  169.     dup -> #parms  c,            \ store # parms for 68k
  170.     DP -> ^68kInfo
  171.     #parms
  172.     iF    pad #parms n,            \ reserve space for rest of 68k parm info
  173.         #parms
  174.         FOR
  175.         \ #bytes in next PPC parm - convert to #cells and accumulate
  176.             3 +  2 >>  ++> #cells
  177.         \ 68k parm info
  178.             i true 68k_parm_adjust    \ check if reg-based and take care of it
  179.             ^68kInfo i + c!        \ store in right order in 68k info
  180.         NEXT
  181.     THEN
  182.     #cells ^PPCinfo c!            \ store # PPC parm cells at ^PPCinfo
  183.  
  184. \ # result bytes
  185.     3 + 2 >>  ^PPCinfo 1+ c!    \ store # PPC result cells at ^PPCinfo+1
  186.     0 false 68k_parm_adjust  c,    \ store 68k info.  We don't
  187.                                 \  round here since we have to know whether
  188.                                 \  and by how much to adjust by at the end
  189.                                 \  of the call.
  190.     align-dp
  191.     read_inline
  192.     reset: temp  len: temp  w,  all: temp  n,
  193.  
  194.     0 -> src-len        \ on the PPC we ignore the 68k inline code sequence
  195. ;
  196.  
  197.  
  198. : FIND_IN_CALLSMOD    \ ( s255 \ svCaseFlg -- cfa true | -- s255 false )
  199.     find: callsMod
  200. ;
  201.  
  202.  
  203. : myHeader
  204.     PPC? IF  ppc_header  ELSE  header  THEN  ;
  205.  
  206.  
  207. : KONST  { \ svCaseFlg -- konst }
  208.     case_in_names? -> svCaseFlg
  209.     true -> case_in_names?
  210.     ['] find_in_callsMod  -> extraFind
  211.     '
  212.     svCaseFlg -> case_in_names?
  213.     0 -> extraFind
  214.     dup 2- w@x  -4 <>  abort" not a konst!"
  215.     @  postpone lit
  216. ;        immediate
  217.  
  218.  
  219. : $>KONST  { addr len \ svCaseFlg -- konst }
  220.     case_in_names? -> svCaseFlg
  221.     true -> case_in_names?
  222.     ['] find_in_callsMod  -> extraFind
  223.     addr len sFind
  224.     svCaseFlg -> case_in_names?
  225.     0 -> extraFind
  226.     NIF  abort" konst not defined"  THEN
  227.     dup 2- w@x  -4 <>  abort" not a konst!"
  228.     @
  229. ;
  230.  
  231.  
  232. : SYSCALL  { \    svCaseFlg sv-in addr #parms
  233.                 #parm_cells #res_cells
  234.                 len ^len-byte  name_len  -- }
  235.     ?exec
  236.     >in @  -> sv-in
  237.  
  238. \ first, is it actually a call?
  239.  
  240.     case_in_names? -> svCaseFlg
  241.     true -> case_in_names?
  242.     ['] find_in_callsMod  -> extraFind
  243.     mword find NIF  150 die  THEN        \ "can't find call for this name"
  244.     0 -> extraFind  svCaseFlg -> case_in_names?
  245.     -> addr
  246.     addr 2- w@
  247.     dup 1 and  -> register_based?
  248.     -2 and  $ D000 <>  abort" not a call!"
  249.  
  250. \ now, if we've already defined it as a sysCall for the same processor?
  251. \  If so, we don't need to do it again.
  252.  
  253.     sv-in  >in !
  254.     defined?
  255.     IF    2- w@x
  256.         CASE[ -120 ], [ -122 ]=>    PPC? 0EXIT
  257.             [ $ BF01 ]=>            PPC? ?EXIT
  258.             DEFAULT=>  drop
  259.         ]CASE
  260.     ELSE
  261.         drop
  262.     THEN
  263.  
  264.     sv-in  >in !
  265.  
  266.     PPC?
  267.     IF    myHeader  $ BF01  codeW,
  268.         addr c@        -> #parm_cells
  269.         addr 1+ c@    -> #res_cells
  270.         #res_cells codeC,  #parm_cells codeC,
  271.         nilP code,
  272.         addr >name n>count dup -> name_len
  273.         CDP place
  274.         name_len 2+ #align4  ++> CDP
  275.     ELSE
  276.         header
  277.         register_based?  IF  -122  ELSE  -120  THEN
  278.         w,                        \ sysCall_h handler for 68k
  279.         2 ++> addr                \ look at 68k parm info
  280.         addr c@  -> #parms
  281.         DP -> ^len-byte  0 c,    \ total length of call info will go here
  282.         #parms c,
  283.         1 ++> addr
  284.         #parms 1+ FOR            \ add 1 since we're including the result byte
  285.             addr c@  c,  1 ++> addr
  286.         NEXT
  287.         addr 1 and  ++> addr
  288.         1 or> DP                \ put DP to odd bdry since we'll be omitting
  289.                                 \  the length byte 
  290.         addr length  n,            \ move inline code over
  291.         DP ^len-byte - 1-
  292.         ^len-byte c!            \ and store length of call info (excluding length byte)
  293.     THEN
  294. ;
  295.  
  296.  
  297. new: temp
  298.  
  299. true -> case_in_names?
  300. // xcalls
  301. FALSE -> CASE_IN_NAMES?
  302.  
  303. release: temp
  304.  
  305. cr .( Dic room at end of compiling callsMod: )  room . cr
  306.  
  307.